home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / gambit.init < prev    next >
Encoding:
Text File  |  1995-01-04  |  6.4 KB  |  220 lines
  1. ;;;"gambit.init" Initialisation for SLIB for Gambit    -*-scheme-*-
  2. ;;; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; Updated 1992 February 1 for Gambit v1.71 -- by Ken Dickey
  21. ;;; Date: Wed, 12 Jan 1994 15:03:12 -0500
  22. ;;; From: barnett@armadillo.urich.edu (Lewis Barnett)
  23. ;;; Relative pathnames for Slib in MacGambit
  24.  
  25. (define (SOFTWARE-TYPE) 'UNIX)        ; 'MACOS for MacGambit.
  26.  
  27. (define (scheme-implementation-type) 'gambit)
  28.  
  29. (define (scheme-implementation-version) "?")
  30.  
  31. (define SYSTEM ##unix-system)        ; Comment out for 'MACOS
  32.  
  33. ;;; (implementation-vicinity) should be defined to be the pathname of
  34. ;;; the directory where any auxillary files to your Scheme
  35. ;;; implementation reside.
  36.  
  37. (define implementation-vicinity
  38.   (let ((arg0 (vector-ref ##argv 0)))
  39.     (let loop ((i (- (string-length arg0) 1)))
  40.       (cond ((negative? i) "")
  41.         ((char=? #\: (string-ref arg0 i))
  42.          (lambda ()
  43.            (substring arg0 0 (+ i 1))))
  44.         (else (loop (- i 1)))))))
  45.  
  46. ;;; (library-vicinity) should be defined to be the pathname of the
  47. ;;; directory where files of Scheme library functions reside.
  48.  
  49. ;;; This assumes that the slib files are in a folder
  50. ;;; called slib in the same directory as the MacGambit Interpreter.
  51.  
  52. (define library-vicinity
  53.   (let ((library-path
  54.      (case (software-type)
  55.        ((UNIX) "/usr/local/lib/slib/")
  56.        ((MACOS) (string-append (implementation-vicinity) ":slib:"))
  57.        ((AMIGA)    "dh0:scm/Library/")
  58.        ((VMS) "lib$scheme:")
  59.        ((MS-DOS) "C:\\SLIB\\")
  60.        (else ""))))
  61.     (lambda () library-path)))
  62.  
  63. ;;; *features* should be set to a list of symbols describing features
  64. ;;; of this implementation.  See Template.scm for the list of feature
  65. ;;; names.
  66.  
  67. (define *features*
  68.      ((lambda (l)
  69.     (if (eq? (SOFTWARE-TYPE) 'MACOS) l (cons 'system l)))
  70.       '(
  71.     source                ;can load scheme source files
  72.                     ;(slib:load-source "filename")
  73.     compiled            ;can load compiled files
  74.                     ;(slib:load-compiled "filename")
  75.     rev4-report
  76.     ieee-p1178
  77.     sicp
  78.     rev4-optional-procedures
  79.     rev3-procedures
  80.     rev2-procedures
  81.     multiarg/and-
  82.     multiarg-apply
  83.     object-hash
  84.     rationalize
  85.     delay
  86.     with-file
  87.     transcript
  88.     char-ready?
  89.     ieee-floating-point
  90.     full-continuation
  91.     )))
  92.  
  93. ;;; (OUTPUT-PORT-WIDTH <port>)
  94. (define (output-port-width . arg) 79)
  95.  
  96. ;;; (OUTPUT-PORT-HEIGHT <port>)
  97. (define (output-port-height . arg) 24)
  98.  
  99. ;;; (CURRENT-ERROR-PORT)
  100. (define current-error-port
  101.   (let ((port (current-output-port)))
  102.     (lambda () port)))
  103.  
  104. ;;; (TMPNAM) makes a temporary file name.
  105. (define tmpnam
  106.   (let ((cntr 100))
  107.     (lambda () (set! cntr (+ 1 cntr))
  108.         (let ((tmp (string-append "slib_" (number->string cntr))))
  109.           (if (file-exists? tmp) (tmpnam) tmp)))))
  110.  
  111. ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
  112. ;;; use this definition if your system doesn't have such a procedure.
  113. (define (force-output . arg) #t)
  114.  
  115. ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
  116. ;;; be returned by CHAR->INTEGER.
  117. (define char-code-limit 256)
  118.  
  119. ;; MOST-POSITIVE-FIXNUM is used in modular.scm
  120. (define most-positive-fixnum #x1FFFFFFF)  ;; 3-bit tag for 68K
  121.  
  122. ;;; Return argument
  123. (define (identity x) x)
  124.  
  125. ;;; If your implementation provides eval, SLIB:EVAL is single argument
  126. ;;; eval using the top-level (user) environment.
  127. (define SLIB:EVAL ##eval-global);; Gambit v1.71
  128.  
  129. ;;; If your implementation provides R4RS macros:
  130. ;(define macro:eval slib:eval)
  131. ;(define macro:load load)
  132.  
  133. (define *defmacros*
  134.   (list (cons 'defmacro
  135.           (lambda (name parms . body)
  136.         `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
  137.                       *defmacros*))))))
  138. (define (defmacro? m) (and (assq m *defmacros*) #t))
  139.  
  140. (define (macroexpand-1 e)
  141.   (if (pair? e) (let ((a (car e)))
  142.           (cond ((symbol? a) (set! a (assq a *defmacros*))
  143.                      (if a (apply (cdr a) (cdr e)) e))
  144.             (else e)))
  145.       e))
  146.  
  147. (define (macroexpand e)
  148.   (if (pair? e) (let ((a (car e)))
  149.           (cond ((symbol? a)
  150.              (set! a (assq a *defmacros*))
  151.              (if a (macroexpand (apply (cdr a) (cdr e))) e))
  152.             (else e)))
  153.       e))
  154.  
  155. (define gentemp
  156.   (let ((*gensym-counter* -1))
  157.     (lambda ()
  158.       (set! *gensym-counter* (+ *gensym-counter* 1))
  159.       (string->symbol
  160.        (string-append "slib:G" (number->string *gensym-counter*))))))
  161.  
  162. (define base:eval slib:eval)
  163. (define (defmacro:eval x) (base:eval (defmacro:expand* x)))
  164. (define (defmacro:expand* x)
  165.   (require 'defmacroexpand) (apply defmacro:expand* x '()))
  166.  
  167. (define (defmacro:load <pathname>)
  168.   (slib:eval-load <pathname> defmacro:eval))
  169.  
  170. (define (slib:eval-load <pathname> evl)
  171.   (if (not (file-exists? <pathname>))
  172.       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
  173.   (call-with-input-file <pathname>
  174.     (lambda (port)
  175.       (let ((old-load-pathname *load-pathname*))
  176.     (set! *load-pathname* <pathname>)
  177.     (do ((o (read port) (read port)))
  178.         ((eof-object? o))
  179.       (evl o))
  180.     (set! *load-pathname* old-load-pathname)))))
  181.  
  182. ;; define an error procedure for the library
  183. (define SLIB:ERROR error)
  184.  
  185. ;; define these as appropriate for your system.
  186. (define slib:tab (integer->char 9))
  187. (define slib:form-feed (integer->char 12))
  188.  
  189. (define (1+ n) (+ n 1))
  190. (define (-1+ n) (- n 1))
  191. (define 1- -1+)
  192.  
  193. (define in-vicinity string-append)
  194.  
  195. ;;; Define SLIB:EXIT to be the implementation procedure to exit or
  196. ;;; return if exitting not supported.
  197. (define slib:exit (lambda args (exit)))
  198.  
  199. ;;; Here for backward compatability
  200.  
  201. (define (scheme-file-suffix) ".scm")
  202.  
  203. ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
  204. ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
  205.  
  206. (define slib:load-source load)
  207.  
  208. ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
  209. ;;; by compiling "foo.scm" if this implementation can compile files.
  210. ;;; See feature 'COMPILED.
  211.  
  212. (define slib:load-compiled load)
  213.  
  214. ;;; At this point SLIB:LOAD must be able to load SLIB files.
  215.  
  216. (define slib:load slib:load-source)
  217.  
  218. (slib:load (in-vicinity (library-vicinity) "require"))
  219. ;;;            --- E O F ---
  220.